home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / jka-compr.el.z / jka-compr.el
Encoding:
Text File  |  1998-05-21  |  26.4 KB  |  874 lines
  1. ;;; jka-compr.el --- reading/writing/loading compressed files
  2.  
  3. ;; Copyright (C) 1993, 1994  Free Software Foundation, Inc.
  4.  
  5. ;; Author: jka@ece.cmu.edu (Jay K. Adams)
  6. ;; Keywords: data
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;; Synched up with: FSF 19.34
  26.  
  27. ;;; Commentary: 
  28.  
  29. ;; This package implements low-level support for reading, writing,
  30. ;; and loading compressed files.  It hooks into the low-level file
  31. ;; I/O functions (including write-region and insert-file-contents) so
  32. ;; that they automatically compress or uncompress a file if the file
  33. ;; appears to need it (based on the extension of the file name).
  34. ;; Packages like Rmail, VM, GNUS, and Info should be able to work
  35. ;; with compressed files without modification.
  36.  
  37.  
  38. ;; INSTRUCTIONS:
  39. ;;
  40. ;; To use jka-compr, simply load this package, and edit as usual.
  41. ;; Its operation should be transparent to the user (except for
  42. ;; messages appearing when a file is being compressed or
  43. ;; uncompressed).
  44. ;;
  45. ;; The variable, jka-compr-compression-info-list can be used to
  46. ;; customize jka-compr to work with other compression programs.
  47. ;; The default value of this variable allows jka-compr to work with
  48. ;; Unix compress and gzip.
  49. ;;
  50. ;; If you are concerned about the stderr output of gzip and other
  51. ;; compression/decompression programs showing up in your buffers, you
  52. ;; should set the discard-error flag in the compression-info-list.
  53. ;; This will cause the stderr of all programs to be discarded.
  54. ;; However, it also causes emacs to call compression/uncompression
  55. ;; programs through a shell (which is specified by jka-compr-shell).
  56. ;; This may be a drag if, on your system, starting up a shell is
  57. ;; slow.
  58. ;;
  59. ;; If you don't want messages about compressing and decompressing
  60. ;; to show up in the echo area, you can set the compress-name and
  61. ;; decompress-name fields of the jka-compr-compression-info-list to
  62. ;; nil.
  63.  
  64.  
  65. ;; APPLICATION NOTES:
  66. ;;
  67. ;; crypt++
  68. ;;   jka-compr can coexist with crypt++ if you take all the decompression
  69. ;;   entries out of the crypt-encoding-list.  Clearly problems will arise if
  70. ;;   you have two programs trying to compress/decompress files.  jka-compr
  71. ;;   will not "work with" crypt++ in the following sense: you won't be able to
  72. ;;   decode encrypted compressed files--that is, files that have been
  73. ;;   compressed then encrypted (in that order).  Theoretically, crypt++ and
  74. ;;   jka-compr could properly handle a file that has been encrypted then
  75. ;;   compressed, but there is little point in trying to compress an encrypted
  76. ;;   file.
  77. ;;
  78.  
  79.  
  80. ;; ACKNOWLEDGMENTS
  81. ;; 
  82. ;; jka-compr is a V19 adaptation of jka-compr for V18 of Emacs.  Many people
  83. ;; have made helpful suggestions, reported bugs, and even fixed bugs in 
  84. ;; jka-compr.  I recall the following people as being particularly helpful.
  85. ;;
  86. ;;   Jean-loup Gailly
  87. ;;   David Hughes
  88. ;;   Richard Pieri
  89. ;;   Daniel Quinlan
  90. ;;   Chris P. Ross
  91. ;;   Rick Sladkey
  92. ;;
  93. ;; Andy Norman's ange-ftp was the inspiration for the original jka-compr for
  94. ;; Version 18 of Emacs.
  95. ;;
  96. ;; After I had made progress on the original jka-compr for V18, I learned of a
  97. ;; package written by Kazushi Jam Marukawa, called jam-zcat, that did exactly
  98. ;; what I was trying to do.  I looked over the jam-zcat source code and
  99. ;; probably got some ideas from it.
  100. ;;
  101.  
  102. ;;; Code:
  103.  
  104. (defgroup compression nil
  105.   "Data compression utilities"
  106.   :group 'data)
  107.  
  108. (defgroup jka-compr nil
  109.   "jka-compr customization"
  110.   :group 'compression)
  111.  
  112.  
  113. (defcustom jka-compr-shell "sh"
  114.   "*Shell to be used for calling compression programs.
  115. The value of this variable only matters if you want to discard the
  116. stderr of a compression/decompression program (see the documentation
  117. for `jka-compr-compression-info-list')."
  118.   :type 'string
  119.   :group 'jka-compr)
  120.  
  121. (defvar jka-compr-use-shell t)
  122.  
  123.  
  124. ;;; I have this defined so that .Z files are assumed to be in unix
  125. ;;; compress format; and .gz files, in gzip format.
  126. (defcustom jka-compr-compression-info-list
  127.   ;;[regexp
  128.   ;; compr-message  compr-prog  compr-args
  129.   ;; uncomp-message uncomp-prog uncomp-args
  130.   ;; can-append auto-mode-flag]
  131.   '(["\\.Z\\(~\\|\\.~[0-9]+~\\)?\\'"
  132.      "compressing"    "compress"     ("-c")
  133.      "uncompressing"  "uncompress"   ("-c")
  134.      nil t]
  135.     ["\\.tgz\\'"
  136.      "zipping"        "gzip"         ("-c" "-q")
  137.      "unzipping"      "gzip"         ("-c" "-q" "-d")
  138.      t nil]
  139.     ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'"
  140.      "zipping"        "gzip"         ("-c" "-q")
  141.      "unzipping"      "gzip"         ("-c" "-q" "-d")
  142.      t t]
  143.     ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'"
  144.      "bzipping"       "bzip2"        ("-f")
  145.      "unbzipping"     "bzip2"        ("-d")
  146.      nil t])
  147.  
  148.   "List of vectors that describe available compression techniques.
  149. Each element, which describes a compression technique, is a vector of
  150. the form [REGEXP COMPRESS-MSG COMPRESS-PROGRAM COMPRESS-ARGS
  151. UNCOMPRESS-MSG UNCOMPRESS-PROGRAM UNCOMPRESS-ARGS
  152. APPEND-FLAG EXTENSION], where:
  153.  
  154.    regexp                is a regexp that matches filenames that are
  155.                          compressed with this format
  156.  
  157.    compress-msg          is the message to issue to the user when doing this
  158.                          type of compression (nil means no message)
  159.  
  160.    compress-program      is a program that performs this compression
  161.  
  162.    compress-args         is a list of args to pass to the compress program
  163.  
  164.    uncompress-msg        is the message to issue to the user when doing this
  165.                          type of uncompression (nil means no message)
  166.  
  167.    uncompress-program    is a program that performs this compression
  168.  
  169.    uncompress-args       is a list of args to pass to the uncompress program
  170.  
  171.    append-flag           is non-nil if files compressed with this technique can
  172.                          be appended to without decompressing them first.
  173.  
  174.    auto-mode flag        non-nil means strip the regexp from file names
  175.                          before attempting to set the mode.
  176.  
  177. Because of the way `call-process' is defined, discarding the stderr output of
  178. a program adds the overhead of starting a shell each time the program is
  179. invoked."
  180.   :type '(repeat (vector :tag "Compression Technique"
  181.              regexp
  182.              (choice :tag "Compress Message"
  183.                  (string :format "%v")
  184.                  (const :tag "No Message" nil))
  185.              (string :tag "Compress Program")
  186.              (repeat :tag "Compress Arguments" string)
  187.              (choice :tag "Uncompress Message"
  188.                  (string :format "%v")
  189.                  (const :tag "No Message" nil))
  190.              (string :tag "Uncompress Program")
  191.              (repeat :tag "Uncompress Arguments" string)
  192.              (boolean :tag "Append")
  193.              (boolean :tag "Auto Mode")))
  194.   :group 'jka-compr)
  195.  
  196. (defvar jka-compr-mode-alist-additions
  197.   (list (cons "\\.tgz\\'" 'tar-mode))
  198.   "A list of pairs to add to auto-mode-alist when jka-compr is installed.")
  199.  
  200. (defvar jka-compr-file-name-handler-entry
  201.   nil
  202.   "The entry in `file-name-handler-alist' used by the jka-compr I/O functions.")
  203.  
  204. ;;; Functions for accessing the return value of jka-compr-get-compression-info
  205. (defun jka-compr-info-regexp               (info)  (aref info 0))
  206. (defun jka-compr-info-compress-message     (info)  (aref info 1))
  207. (defun jka-compr-info-compress-program     (info)  (aref info 2))
  208. (defun jka-compr-info-compress-args        (info)  (aref info 3))
  209. (defun jka-compr-info-uncompress-message   (info)  (aref info 4))
  210. (defun jka-compr-info-uncompress-program   (info)  (aref info 5))
  211. (defun jka-compr-info-uncompress-args      (info)  (aref info 6))
  212. (defun jka-compr-info-can-append           (info)  (aref info 7))
  213. (defun jka-compr-info-strip-extension      (info)  (aref info 8))
  214.  
  215.  
  216. (defun jka-compr-get-compression-info (filename)
  217.   "Return information about the compression scheme of FILENAME.
  218. The determination as to which compression scheme, if any, to use is
  219. based on the filename itself and `jka-compr-compression-info-list'."
  220.   (catch 'compression-info
  221.     (let ((case-fold-search nil))
  222.       (mapcar
  223.        (function (lambda (x)
  224.            (and (string-match (jka-compr-info-regexp x) filename)
  225.             (throw 'compression-info x))))
  226.        jka-compr-compression-info-list)
  227.       nil)))
  228.  
  229.  
  230. ;; XEmacs change
  231. (define-error 'compression-error "Compression error" 'file-error)
  232.  
  233. (defvar jka-compr-acceptable-retval-list '(0 2 141))
  234.  
  235.  
  236. (defun jka-compr-error (prog args infile message &optional errfile)
  237.   (let ((errbuf (get-buffer-create " *jka-compr-error*"))
  238.     (curbuf (current-buffer)))
  239.     (set-buffer errbuf)
  240.     (widen) (erase-buffer)
  241.     (insert (format "Error while executing \"%s %s < %s\"\n\n"
  242.              prog
  243.              (mapconcat 'identity args " ")
  244.              infile))
  245.  
  246.      (and errfile
  247.       (insert-file-contents errfile))
  248.  
  249.      (set-buffer curbuf)
  250.      (display-buffer errbuf))
  251.   (signal 'compression-error (list "Opening input file"
  252.                    (format "error %s" message)
  253.                    infile)))
  254.  
  255.  
  256. (defvar jka-compr-dd-program
  257.   "/bin/dd")
  258.  
  259.  
  260. (defvar jka-compr-dd-blocksize 256)
  261.  
  262.  
  263. (defun jka-compr-partial-uncompress (prog message args infile beg len)
  264.   "Call program PROG with ARGS args taking input from INFILE.
  265. Fourth and fifth args, BEG and LEN, specify which part of the output
  266. to keep: LEN chars starting BEG chars from the beginning."
  267.   (let* ((skip (/ beg jka-compr-dd-blocksize))
  268.      (prefix (- beg (* skip jka-compr-dd-blocksize)))
  269.      (count (and len (1+ (/ (+ len prefix) jka-compr-dd-blocksize))))
  270.      (start (point))
  271.      (err-file (jka-compr-make-temp-name))
  272.      (run-string (format "%s %s 2> %s | %s bs=%d skip=%d %s 2> /dev/null"
  273.                  prog
  274.                  (mapconcat 'identity args " ")
  275.                  err-file
  276.                  jka-compr-dd-program
  277.                  jka-compr-dd-blocksize
  278.                  skip
  279.                  ;; dd seems to be unreliable about
  280.                  ;; providing the last block.  So, always
  281.                  ;; read one more than you think you need.
  282.                  (if count (concat "count=" (1+ count)) ""))))
  283.  
  284.     (unwind-protect
  285.     (or (memq (call-process jka-compr-shell
  286.                 infile t nil "-c"
  287.                 run-string)
  288.           jka-compr-acceptable-retval-list)
  289.         
  290.         (jka-compr-error prog args infile message err-file))
  291.  
  292.       (jka-compr-delete-temp-file err-file))
  293.  
  294.     ;; Delete the stuff after what we want, if there is any.
  295.     (and
  296.      len
  297.      (< (+ start prefix len) (point))
  298.      (delete-region (+ start prefix len) (point)))
  299.  
  300.     ;; Delete the stuff before what we want.
  301.     (delete-region start (+ start prefix))))
  302.  
  303.  
  304. (defun jka-compr-call-process (prog message infile output temp args)
  305.   (if jka-compr-use-shell
  306.  
  307.       (let ((err-file (jka-compr-make-temp-name)))
  308.         
  309.     (unwind-protect
  310.  
  311.         (or (memq
  312.          (call-process jka-compr-shell infile
  313.                    (if (stringp output) nil output)
  314.                    nil
  315.                    "-c"
  316.                    (format "%s %s 2> %s %s"
  317.                        prog
  318.                        (mapconcat 'identity args " ")
  319.                        err-file
  320.                        (if (stringp output)
  321.                        (concat "> " output)
  322.                      "")))
  323.          jka-compr-acceptable-retval-list)
  324.  
  325.         (jka-compr-error prog args infile message err-file))
  326.  
  327.       (jka-compr-delete-temp-file err-file)))
  328.  
  329.     (or (zerop
  330.      (apply 'call-process
  331.         prog
  332.         infile
  333.         (if (stringp output) temp output)
  334.         nil
  335.         args))
  336.     (jka-compr-error prog args infile message))
  337.  
  338.     (and (stringp output)
  339.      (let ((cbuf (current-buffer)))
  340.        (set-buffer temp)
  341.        (write-region (point-min) (point-max) output)
  342.        (erase-buffer)
  343.        (set-buffer cbuf)))))
  344.  
  345.  
  346. ;;; Support for temp files.  Much of this was inspired if not lifted
  347. ;;; from ange-ftp.
  348.  
  349. (defcustom jka-compr-temp-name-template
  350.   "/tmp/jka-com"
  351.   "Prefix added to all temp files created by jka-compr.
  352. There should be no more than seven characters after the final `/'"
  353.   :type 'string
  354.   :group 'jka-compr)
  355.  
  356. (defvar jka-compr-temp-name-table (make-vector 31 nil))
  357.  
  358. (defun jka-compr-make-temp-name (&optional local-copy)
  359.   "This routine will return the name of a new file."
  360.   (let* ((lastchar ?a)
  361.      (prevchar ?a)
  362.      (template (concat jka-compr-temp-name-template "aa"))
  363.      (lastpos (1- (length template)))
  364.      (not-done t)
  365.      file
  366.      entry)
  367.  
  368.     (while not-done
  369.       (aset template lastpos lastchar)
  370.       (setq file (concat (make-temp-name template) "#"))
  371.       (setq entry (intern file jka-compr-temp-name-table))
  372.       (if (or (get entry 'active)
  373.           (file-exists-p file))
  374.  
  375.       (progn
  376.         (setq lastchar (1+ lastchar))
  377.         (if (> lastchar ?z)
  378.         (progn
  379.           (setq prevchar (1+ prevchar))
  380.           (setq lastchar ?a)
  381.           (if (> prevchar ?z)
  382.               (error "Can't allocate temp file.")
  383.             (aset template (1- lastpos) prevchar)))))
  384.  
  385.     (put entry 'active (not local-copy))
  386.     (setq not-done nil)))
  387.  
  388.     file))
  389.  
  390.  
  391. (defun jka-compr-delete-temp-file (temp)
  392.  
  393.   (put (intern temp jka-compr-temp-name-table)
  394.        'active nil)
  395.  
  396.   (condition-case ()
  397.       (delete-file temp)
  398.     (error nil)))
  399.  
  400. ;;; 20.0-b92 change
  401. ;;; Now receives both `lockname' and `codesys' from Fwrite_region_internal
  402. ;;; what makes it compatible with write-region
  403. (defun jka-compr-write-region (start end file &optional append visit lockname coding-system)
  404.   (let* ((filename (expand-file-name file))
  405.      (visit-file (if (stringp visit) (expand-file-name visit) filename))
  406.      (info (jka-compr-get-compression-info visit-file)))
  407.       
  408.       (if info
  409.  
  410.       (let ((can-append (jka-compr-info-can-append info))
  411.         (compress-program (jka-compr-info-compress-program info))
  412.         (compress-message (jka-compr-info-compress-message info))
  413.         (uncompress-program (jka-compr-info-uncompress-program info))
  414.         (uncompress-message (jka-compr-info-uncompress-message info))
  415.         (compress-args (jka-compr-info-compress-args info))
  416.         (uncompress-args (jka-compr-info-uncompress-args info))
  417.         (base-name (file-name-nondirectory visit-file))
  418.         temp-file cbuf temp-buffer)
  419.  
  420.         (setq cbuf (current-buffer)
  421.           temp-buffer (get-buffer-create " *jka-compr-wr-temp*"))
  422.         (set-buffer temp-buffer)
  423.         (widen) (erase-buffer)
  424.         (set-buffer cbuf)
  425.  
  426.         (if (and append
  427.              (not can-append)
  428.              (file-exists-p filename))
  429.         
  430.         (let* ((local-copy (file-local-copy filename))
  431.                (local-file (or local-copy filename)))
  432.           
  433.           (setq temp-file local-file))
  434.  
  435.           (setq temp-file (jka-compr-make-temp-name)))
  436.  
  437.         (and 
  438.          compress-message
  439.          (message "%s %s..." compress-message base-name))
  440.         
  441.         (jka-compr-run-real-handler 'write-region
  442.                     (list start end temp-file t 'dont lockname coding-system))
  443.  
  444.         (jka-compr-call-process compress-program
  445.                     (concat compress-message
  446.                         " " base-name)
  447.                     temp-file
  448.                     temp-buffer
  449.                     nil
  450.                     compress-args)
  451.  
  452.         (set-buffer temp-buffer)
  453.         (jka-compr-run-real-handler 'write-region
  454.                     (list (point-min) (point-max)
  455.                           filename
  456.                           (and append can-append)
  457.                           'dont lockname 'binary))
  458.         (erase-buffer)
  459.         (set-buffer cbuf)
  460.  
  461.         (jka-compr-delete-temp-file temp-file)
  462.  
  463.         (and
  464.          compress-message
  465.          (message "%s %s...done" compress-message base-name))
  466.  
  467.         (cond
  468.          ((eq visit t)
  469.           (setq buffer-file-name filename)
  470.           (set-visited-file-modtime))
  471.          ((stringp visit)
  472.           (setq buffer-file-name visit)
  473.           (let ((buffer-file-name filename))
  474.         (set-visited-file-modtime))))
  475.  
  476.         (and (or (eq visit t)
  477.              (eq visit nil)
  478.              (stringp visit))
  479.          (message "Wrote %s" visit-file))
  480.  
  481.         nil)
  482.           
  483.     (jka-compr-run-real-handler 'write-region
  484.                     (list start end filename append visit lockname coding-system)))))
  485.  
  486.  
  487. (defun jka-compr-insert-file-contents (file &optional visit beg end replace)
  488.   (barf-if-buffer-read-only)
  489.  
  490.   (and (or beg end)
  491.        visit
  492.        (error "Attempt to visit less than an entire file"))
  493.  
  494.   (let* ((filename (expand-file-name file))
  495.      (info (jka-compr-get-compression-info filename)))
  496.  
  497.     (if info
  498.  
  499.     (let ((uncompress-message (jka-compr-info-uncompress-message info))
  500.           (uncompress-program (jka-compr-info-uncompress-program info))
  501.           (uncompress-args (jka-compr-info-uncompress-args info))
  502.           (base-name (file-name-nondirectory filename))
  503.           (notfound nil)
  504.           (local-copy
  505.            (jka-compr-run-real-handler 'file-local-copy (list filename)))
  506.           local-file
  507.           size start)
  508.  
  509.       (setq local-file (or local-copy filename))
  510.  
  511.       (and
  512.        visit
  513.        (setq buffer-file-name filename))
  514.  
  515.       (unwind-protect        ; to make sure local-copy gets deleted
  516.  
  517.           (progn
  518.           
  519.         (and
  520.          uncompress-message
  521.          (message "%s %s..." uncompress-message base-name))
  522.  
  523.         (condition-case error-code
  524.  
  525.             (progn
  526.               (if replace
  527.               (goto-char (point-min)))
  528.               (setq start (point))
  529.               (if (or beg end)
  530.               (jka-compr-partial-uncompress uncompress-program
  531.                             (concat uncompress-message
  532.                                 " " base-name)
  533.                             uncompress-args
  534.                             local-file
  535.                             (or beg 0)
  536.                             (if (and beg end)
  537.                                 (- end beg)
  538.                               end))
  539.             ;; If visiting, bind off buffer-file-name so that
  540.             ;; file-locking will not ask whether we should
  541.             ;; really edit the buffer.
  542.             (let ((buffer-file-name
  543.                    (if visit nil buffer-file-name)))
  544.               (jka-compr-call-process uncompress-program
  545.                           (concat uncompress-message
  546.                               " " base-name)
  547.                           local-file
  548.                           t
  549.                           nil
  550.                           uncompress-args)))
  551.               (setq size (- (point) start))
  552.               (if replace
  553.               (let* ((del-beg (point))
  554.                  (del-end (+ del-beg size)))
  555.                 (delete-region del-beg
  556.                        (min del-end (point-max)))))
  557.               (goto-char start))
  558.           (error
  559.            (if (and (eq (car error-code) 'file-error)
  560.                 (eq (nth 3 error-code) local-file))
  561.                (if visit
  562.                (setq notfound error-code)
  563.              (signal 'file-error 
  564.                  (cons "Opening input file"
  565.                        (nthcdr 2 error-code))))
  566.              (signal (car error-code) (cdr error-code))))))
  567.  
  568.         (and
  569.          local-copy
  570.          (file-exists-p local-copy)
  571.          (delete-file local-copy)))
  572.  
  573.       (and
  574.        visit
  575.        (progn
  576.          (unlock-buffer)
  577.          (setq buffer-file-name filename)
  578.          (set-visited-file-modtime)))
  579.         
  580.       (and
  581.        uncompress-message
  582.        (message "%s %s...done" uncompress-message base-name))
  583.  
  584.       (and
  585.        visit
  586.        notfound
  587.        (signal 'file-error
  588.            (cons "Opening input file" (nth 2 notfound))))
  589.  
  590.       ;; Run the functions that insert-file-contents would.
  591.       (let ((p after-insert-file-functions)
  592.         (insval size))
  593.         (while p
  594.           (setq insval (funcall (car p) size))
  595.           (if insval
  596.           (progn
  597.             (or (integerp insval)
  598.             (signal 'wrong-type-argument
  599.                 (list 'integerp insval)))
  600.             (setq size insval)))
  601.           (setq p (cdr p))))
  602.  
  603.       (list filename size))
  604.  
  605.       (jka-compr-run-real-handler 'insert-file-contents
  606.                   (list file visit beg end replace)))))
  607.  
  608.  
  609. (defun jka-compr-file-local-copy (file)
  610.   (let* ((filename (expand-file-name file))
  611.      (info (jka-compr-get-compression-info filename)))
  612.  
  613.     (if info
  614.  
  615.     (let ((uncompress-message (jka-compr-info-uncompress-message info))
  616.           (uncompress-program (jka-compr-info-uncompress-program info))
  617.           (uncompress-args (jka-compr-info-uncompress-args info))
  618.           (base-name (file-name-nondirectory filename))
  619.           (local-copy
  620.            (jka-compr-run-real-handler 'file-local-copy (list filename)))
  621.           (temp-file (jka-compr-make-temp-name t))
  622.           (temp-buffer (get-buffer-create " *jka-compr-flc-temp*"))
  623.           (notfound nil)
  624.           (cbuf (current-buffer))
  625.           local-file)
  626.  
  627.       (setq local-file (or local-copy filename))
  628.  
  629.       (unwind-protect
  630.  
  631.           (progn
  632.           
  633.         (and
  634.          uncompress-message
  635.          (message "%s %s..." uncompress-message base-name))
  636.  
  637.         (set-buffer temp-buffer)
  638.           
  639.         (jka-compr-call-process uncompress-program
  640.                     (concat uncompress-message
  641.                         " " base-name)
  642.                     local-file
  643.                     t
  644.                     nil
  645.                     uncompress-args)
  646.  
  647.         (and
  648.          uncompress-message
  649.          (message "%s %s...done" uncompress-message base-name))
  650.  
  651.         (write-region
  652.          (point-min) (point-max) temp-file nil 'dont))
  653.  
  654.         (and
  655.          local-copy
  656.          (file-exists-p local-copy)
  657.          (delete-file local-copy))
  658.  
  659.         (set-buffer cbuf)
  660.         (kill-buffer temp-buffer))
  661.  
  662.       temp-file)
  663.         
  664.       (jka-compr-run-real-handler 'file-local-copy (list filename)))))
  665.  
  666.  
  667. ;;; Support for loading compressed files.
  668. ;;; XEmacs: autoload this function
  669. ;;;###autoload
  670. (defun jka-compr-load (file &optional noerror nomessage nosuffix)
  671.   "Documented as original."
  672.  
  673.   (let* ((local-copy (jka-compr-file-local-copy file))
  674.      (load-file (or local-copy file)))
  675.  
  676.     (unwind-protect
  677.  
  678.     (let (inhibit-file-name-operation
  679.           inhibit-file-name-handlers)
  680.       (or nomessage
  681.           (message "Loading %s..." file))
  682.  
  683.       (let ((load-force-doc-strings t))
  684.         (load load-file noerror t t))
  685.  
  686.       (or nomessage
  687.           (message "Loading %s...done." file)))
  688.  
  689.       (jka-compr-delete-temp-file local-copy))
  690.  
  691.     t))
  692.  
  693. (defun jka-compr-byte-compiler-base-file-name (file)
  694.   (let ((info (jka-compr-get-compression-info file)))
  695.     (if (and info (jka-compr-info-strip-extension info))
  696.     (save-match-data
  697.      (substring file 0 (string-match (jka-compr-info-regexp info) file)))
  698.       file)))
  699.  
  700. (put 'write-region 'jka-compr 'jka-compr-write-region)
  701. (put 'insert-file-contents 'jka-compr 'jka-compr-insert-file-contents)
  702. (put 'file-local-copy 'jka-compr 'jka-compr-file-local-copy)
  703. (put 'load 'jka-compr 'jka-compr-load)
  704. (put 'byte-compiler-base-file-name 'jka-compr
  705.      'jka-compr-byte-compiler-base-file-name)
  706.  
  707. (defun jka-compr-handler (operation &rest args)
  708.   (save-match-data
  709.     (let ((jka-op (get operation 'jka-compr)))
  710.       (if jka-op
  711.       (apply jka-op args)
  712.     (jka-compr-run-real-handler operation args)))))
  713.  
  714. ;; If we are given an operation that we don't handle,
  715. ;; call the Emacs primitive for that operation,
  716. ;; and manipulate the inhibit variables
  717. ;; to prevent the primitive from calling our handler again.
  718. (defun jka-compr-run-real-handler (operation args)
  719.   (let ((inhibit-file-name-handlers
  720.      (cons 'jka-compr-handler
  721.            (and (eq inhibit-file-name-operation operation)
  722.             inhibit-file-name-handlers)))
  723.     (inhibit-file-name-operation operation))
  724.     (apply operation args)))
  725.  
  726. ;;;###autoload(defun auto-compression-mode (&optional arg)
  727. ;;;###autoload  "\
  728. ;;;###autoloadToggle automatic file compression and uncompression.
  729. ;;;###autoloadWith prefix argument ARG, turn auto compression on if positive, else off.
  730. ;;;###autoloadReturns the new status of auto compression (non-nil means on)."
  731. ;;;###autoload  (interactive "P")
  732. ;;;###autoload  (if (not (fboundp 'jka-compr-installed-p))
  733. ;;;###autoload      (progn
  734. ;;;###autoload        (require 'jka-compr)
  735. ;;;###autoload        ;; That turned the mode on, so make it initially off.
  736. ;;;###autoload        (toggle-auto-compression)))
  737. ;;;###autoload  (toggle-auto-compression arg t))
  738.  
  739. ;; XEmacs:  autoload this function
  740. ;;;###autoload
  741. (defun toggle-auto-compression (&optional arg message)
  742.   "Toggle automatic file compression and uncompression.
  743. With prefix argument ARG, turn auto compression on if positive, else off.
  744. Returns the new status of auto compression (non-nil means on).
  745. If the argument MESSAGE is non-nil, it means to print a message
  746. saying whether the mode is now on or off."
  747.   (interactive "P\np")
  748.   (let* ((installed (jka-compr-installed-p))
  749.      (flag (if (null arg)
  750.            (not installed)
  751.          (or (eq arg t) (listp arg) (and (integerp arg) (> arg 0))))))
  752.  
  753.     (cond
  754.      ((and flag installed) t)        ; already installed
  755.  
  756.      ((and (not flag) (not installed)) nil) ; already not installed
  757.  
  758.      (flag
  759.       (jka-compr-install))
  760.  
  761.      (t
  762.       (jka-compr-uninstall)))
  763.  
  764.  
  765.     (and message
  766.      (if flag
  767.          (message "Automatic file (de)compression is now ON.")
  768.        (message "Automatic file (de)compression is now OFF.")))
  769.  
  770.     flag))
  771.  
  772.  
  773. (defun jka-compr-build-file-regexp ()
  774.   (concat
  775.    "\\("
  776.    (mapconcat
  777.     'jka-compr-info-regexp
  778.     jka-compr-compression-info-list
  779.     "\\)\\|\\(")
  780.    "\\)"))
  781.  
  782. ;;;###autoload
  783. (defun jka-compr-install ()
  784.   "Install jka-compr.
  785. This adds entries to `file-name-handler-alist' and `auto-mode-alist'
  786. and `inhibit-first-line-modes-suffixes'."
  787.  
  788.   (setq jka-compr-file-name-handler-entry
  789.     (cons (jka-compr-build-file-regexp) 'jka-compr-handler))
  790.  
  791.   (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry
  792.                       file-name-handler-alist))
  793.  
  794.   (mapcar
  795.    (function (lambda (x)
  796.            (and (jka-compr-info-strip-extension x)
  797.             ;; Make entries in auto-mode-alist so that modes
  798.             ;; are chosen right according to the file names
  799.             ;; sans `.gz'.
  800.             (setq auto-mode-alist
  801.               (cons (list (jka-compr-info-regexp x)
  802.                       nil 'jka-compr)
  803.                 auto-mode-alist))
  804.             ;; Also add these regexps to
  805.             ;; inhibit-first-line-modes-suffixes, so that a
  806.             ;; -*- line in the first file of a compressed tar
  807.             ;; file doesn't override tar-mode.
  808.             ;; XEmacs: the (now)superfluous conditional doesn't hurt
  809.             (and (boundp 'inhibit-first-line-modes-suffixes)
  810.              (setq inhibit-first-line-modes-suffixes
  811.                    (cons (jka-compr-info-regexp x)
  812.                      inhibit-first-line-modes-suffixes))))))
  813.    jka-compr-compression-info-list)
  814.   (setq auto-mode-alist
  815.     (append auto-mode-alist jka-compr-mode-alist-additions)))
  816.  
  817.  
  818. (defun jka-compr-uninstall ()
  819.   "Uninstall jka-compr.
  820. This removes the entries in `file-name-handler-alist' and `auto-mode-alist'
  821. and `inhibit-first-line-modes-suffixes' that were added
  822. by `jka-compr-installed'."
  823.   ;; Delete from inhibit-first-line-modes-suffixes
  824.   ;; what jka-compr-install added.
  825.   (mapcar
  826.      (function (lambda (x)
  827.          (and (jka-compr-info-strip-extension x)
  828.               ;; XEmacs: the (now)superfluous conditional doesn't hurt
  829.               (and (boundp 'inhibit-first-line-modes-suffixes)
  830.                (setq inhibit-first-line-modes-suffixes
  831.                  (delete (jka-compr-info-regexp x)
  832.                      inhibit-first-line-modes-suffixes)))))
  833.            )
  834.      jka-compr-compression-info-list)
  835.  
  836.   (let* ((fnha (cons nil file-name-handler-alist))
  837.      (last fnha))
  838.  
  839.     (while (cdr last)
  840.       (if (eq (cdr (car (cdr last))) 'jka-compr-handler)
  841.       (setcdr last (cdr (cdr last)))
  842.     (setq last (cdr last))))
  843.  
  844.     (setq file-name-handler-alist (cdr fnha)))
  845.  
  846.   (let* ((ama (cons nil auto-mode-alist))
  847.      (last ama)
  848.      entry)
  849.  
  850.     (while (cdr last)
  851.       (setq entry (car (cdr last)))
  852.       (if (or (member entry jka-compr-mode-alist-additions)
  853.           (and (consp (cdr entry))
  854.            (eq (nth 2 entry) 'jka-compr)))
  855.       (setcdr last (cdr (cdr last)))
  856.     (setq last (cdr last))))
  857.     
  858.     (setq auto-mode-alist (cdr ama))))
  859.  
  860.       
  861. (defun jka-compr-installed-p ()
  862.   "Return non-nil if jka-compr is installed.
  863. The return value is the entry in `file-name-handler-alist' for jka-compr."
  864.   (rassq 'jka-compr-handler file-name-handler-alist))
  865.  
  866.  
  867. ;; No no no no!
  868. ;(jka-compr-install)
  869.  
  870.  
  871. (provide 'jka-compr)
  872.  
  873. ;; jka-compr.el ends here.
  874.